Windows Game Programming for Dummies (2nd Edition)/WinGamProgFD.iso/pc/DirectX SDK/DXSDK/samples/Multimedia/VBSamples/DirectShow/Editing/TrimmerVB/modGeneral.bas

BASIC Source File | 2001-10-08 | 20.5 KB | 412 lines

Attribute VB_Name = "modGeneral"
'*******************************************************************************
'*       This is a part of the Microsoft DXSDK Code Samples.
'*       Copyright (C) 1999-2001 Microsoft Corporation.
'*       All rights reserved.
'*       This source code is only intended as a supplement to
'*       Microsoft Development Tools and/or SDK documentation.
'*       See these sources for detailed information regarding the
'*       Microsoft samples programs.
'*******************************************************************************
Option Explicit
Option Base 0
Option Compare Text



' **************************************************************************************************************************************
' * PUBLIC INTERFACE- WIN32 API CONSTANTS
' *
' *
            Public Const FO_COPY = &H2
            Public Const FO_DELETE = &H3
            Public Const FO_MOVE = &H1
            Public Const FO_RENAME = &H4
            Public Const FOF_ALLOWUNDO = &H40
            Public Const FOF_CONFIRMMOUSE = &H2
            Public Const FOF_FILESONLY = &H80      ''"" on *.*, do only files
            Public Const FOF_MULTIDESTFILES = &H1
            Public Const FOF_NOCONFIRMATION = &H10      ''"" Don't prompt the user.
            Public Const FOF_NOCONFIRMMKDIR = &H200     ''"" don't confirm making any needed dirs
            Public Const FOF_NOCOPYSECURITYATTRIBS = &H800     ''"" dont copy NT file Security Attributes
            Public Const FOF_NOERRORUI = &H400     ''"" don't put up error UI
            Public Const FOF_NORECURSION = &H1000    ''"" don't recurse into directories.
            Public Const FOF_NO_CONNECTED_ELEMENTS = &H2000    ''"" don't operate on connected file elements.
            Public Const FOF_RENAMEONCOLLISION = &H8
            Public Const FOF_SILENT = &H4       ''"" don't create progress"report
            Public Const FOF_SIMPLEPROGRESS = &H100     ''"" means don't show names of files
            Public Const FOF_WANTMAPPINGHANDLE = &H20      ''"" Fill in SHFILEOPSTRUCT.hNameMappings
            Private Const MAX_PATH As Long = 255
            Private Const INVALID_HANDLE_VALUE = -1
            Private Const SEM_FAILCRITICALERRORS = &H1
            Private Const SEM_NOOPENFILEERRORBOX = &H8000
            Private Const SEE_MASK_CLASSKEY = &H3
            Private Const SEE_MASK_CLASSNAME = &H1
            Private Const SEE_MASK_CONNECTNETDRV = &H80
            Private Const SEE_MASK_DOENVSUBST = &H200
            Private Const SEE_MASK_FLAG_DDEWAIT = &H100
            Private Const SEE_MASK_FLAG_NO_UI = &H400
            Private Const SEE_MASK_HOTKEY = &H20
            Private Const SEE_MASK_ICON = &H10
            Private Const SEE_MASK_IDLIST = &H4
            Private Const SEE_MASK_INVOKEIDLIST = &HC
            Private Const SEE_MASK_NOCLOSEPROCESS = &H40

' **************************************************************************************************************************************
' * PUBLIC INTERFACE- WIN32 API DATA STRUCTURES
' *
' *
            Private Type FILETIME
                    dwLowDateTime As Long
                    dwHighDateTime As Long
            End Type

            Public Type WIN32_FIND_DATA
                    dwFileAttributes As Long
                    ftCreationTime As FILETIME
                    ftLastAccessTime As FILETIME
                    ftLastWriteTime As FILETIME
                    nFileSizeHigh As Long
                    nFileSizeLow As Long
                    dwReserved0 As Long
                    dwReserved1 As Long
                    cFileName As String * MAX_PATH
                    cAlternate As String * 14
            End Type

            Private Type SHFILEOPSTRUCT
                    hWnd As Long
                    wFunc As Long
                    pFrom As String
                    pTo As String
                    fFlags As Integer
                    fAnyOperationsAborted As Long
                    hNameMappings As Long
                    lpszProgressTitle As String '  only used if FOF_SIMPLEPROGRESS
            End Type

            Private Type SHELLEXECUTEINFO
                    cbSize As Long
                    fMask As Long
                    hWnd As Long
                    lpVerb As String
                    lpFile As String
                    lpParameters As String
                    lpDirectory As String
                    nShow As Long
                    hInstApp As Long
                    '  Optional fields
                    lpIdList As Long
                    lpClass As String
                    hkeyClass As Long
                    dwHotKey As Long
                    hIcon As Long
                    hProcess As Long
            End Type


' **************************************************************************************************************************************
' * PUBLIC INTERFACE- WIN32 API DECLARATIONS
' *
' *
            Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
            Private Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long
            Private Declare Function ShellExecuteEx Lib "shell32" (lpExecInfo As SHELLEXECUTEINFO) As Long
            Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
            Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
            Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long





' **************************************************************************************************************************************
' * PUBLIC INTERFACE- DEXTER PROCEDURES
' *
' *
            ' ******************************************************************************************************************************
            ' * procedure name: GetPinInfo
            ' * procedure description:  Returns an IPinInfo interface given a filtergraph manager and IPin object.
            ' *                                       The derived IPinInfo interface can be utilized for gaining information on the elected pin.
            ' ******************************************************************************************************************************
            Public Function GetPinInfo(objFilterGraphManager As FilgraphManager, objPin As IPin) As IPinInfo
            Dim objPin2 As IPin
            Dim objPinInfo As IPinInfo
            Dim objFilterInfo As IFilterInfo
            Dim objPinCollection As Object
            Dim objlFilterCollection As Object
            On Local Error GoTo ErrLine

            'derive a filter collection from the filtergraph manager
            Set objlFilterCollection = objFilterGraphManager.FilterCollection

            'enumerate through the filter(s) in the collection
            For Each objFilterInfo In objlFilterCollection
                Set objPinCollection = objFilterInfo.Pins
                For Each objPinInfo In objPinCollection
                    Set objPin2 = objPinInfo.Pin
                    If objPin2 Is objPin Then
                        Set GetPinInfo = objPinInfo
                        Exit Function
                    End If
                Next
            Next

            'clean-up & dereference
            If Not objPin2 Is Nothing Then Set objPin2 = Nothing
            If Not objPinInfo Is Nothing Then Set objPinInfo = Nothing
            If Not objFilterInfo Is Nothing Then Set objFilterInfo = Nothing
            If Not objPinCollection Is Nothing Then Set objPinCollection = Nothing
            If Not objlFilterCollection Is Nothing Then Set objlFilterCollection = Nothing
            Exit Function

ErrLine:
            Err.Clear
            Exit Function
            End Function


            ' ******************************************************************************************************************************
            ' * procedure name: AddFileWriterAndMux
            ' * procedure description:  Appends a filewriter and mux filter to the given filtergraph.
            ' *                                       The FileName as required for the filewriter and evaluates to the output file destination.
            ' ******************************************************************************************************************************
            Public Sub AddFileWriterAndMux(objFilterGraphManager As FilgraphManager, bstrFileName As String)
            Dim objFilterInfo As IFilterInfo
            Dim objRegisteredFilters As Object
            Dim objAVIMuxFilterInfo As IFilterInfo
            Dim objRegFilterInfo As IRegFilterInfo
            Dim objFileSinkFilterVB As IFileSinkFilterForVB
            On Local Error GoTo ErrLine

            'derive a collection of registered filters from the filtergraph manager
            Set objRegisteredFilters = objFilterGraphManager.RegFilterCollection

            'enumerate through the registered filters
            For Each objRegFilterInfo In objRegisteredFilters
                If Trim(LCase(objRegFilterInfo.Name)) = "file writer" Then
                    objRegFilterInfo.Filter objFilterInfo
                ElseIf Trim(LCase(objRegFilterInfo.Name)) = "avi mux" Then
                    objRegFilterInfo.Filter objAVIMuxFilterInfo
                End If
            Next

            'derive the file sink filter tailored for vb
            Set objFileSinkFilterVB = objFilterInfo.Filter
            'assign the filename to the sink filter
            Call objFileSinkFilterVB.SetFileName(bstrFileName, Nothing)

            'clean-up & dereference
            If Not objFilterInfo Is Nothing Then Set objFilterInfo = Nothing
            If Not objRegFilterInfo Is Nothing Then Set objRegFilterInfo = Nothing
            If Not objFileSinkFilterVB Is Nothing Then Set objFileSinkFilterVB = Nothing
            If Not objAVIMuxFilterInfo Is Nothing Then Set objAVIMuxFilterInfo = Nothing
            If Not objRegisteredFilters Is Nothing Then Set objRegisteredFilters = Nothing
            Exit Sub

ErrLine:
            Err.Clear
            Exit Sub
            End Sub


            ' ******************************************************************************************************************************
            ' * procedure name: RenderGroupPins
            ' * procedure description:  Renders the Pins out for the given timeline using the given render engine.
            ' *
            ' ******************************************************************************************************************************
            Public Sub RenderGroupPins(objRenderEngine As RenderEngine, objTimeline As AMTimeline)
            Dim objPin As IPin
            Dim nCount As Long
            Dim nGroupCount As Long
            Dim objPinInfo As IPinInfo
            Dim objFilterGraphManager As FilgraphManager
            On Local Error GoTo ErrLine

            If Not objTimeline Is Nothing Then
               If Not objRenderEngine Is Nothing Then
                  'obtain the group count
                  objTimeline.GetGroupCount nGroupCount
                  'exit the procedure if there are no group(s)
                  If nGroupCount = 0 Then Exit Sub
                  'obtain the filtergraph
                  objRenderEngine.GetFilterGraph objFilterGraphManager
                  'enumerate through the groups & render the pins
                   For nCount = 0 To nGroupCount - 1
                       objRenderEngine.GetGroupOutputPin nCount, objPin
                       If Not objPin Is Nothing Then
                           Set objPinInfo = GetPinInfo(objFilterGraphManager, objPin)
                           If Not objPinInfo Is Nothing Then
                               Call objPinInfo.Render
                           End If
                       End If
                   Next
               End If
            End If
            Exit Sub

ErrLine:
            Err.Clear
            Resume Next
            Exit Sub
            End Sub



' **************************************************************************************************************************************
' * PUBLIC INTERFACE- GENERAL PROCEDURES
' *
' *
            ' ******************************************************************************************************************************
            ' * procedure name: Buffer_ParseEx
            ' * procedure description:   Parse's a fixed length string buffer of all vbNullCharacters AND vbNullStrings.
            ' *                                        Argument bstrBuffer evaluates to either an ANSII or Unicode BSTR string buffer.
            ' *                                        (bstrBuffer is almost always the output from a windows api call which needs parsed)
            ' *
            ' ******************************************************************************************************************************
            Public Function Buffer_ParseEx(bstrBuffer As String) As String
            Dim iCount As Long, bstrChar As String, bstrReturn As String
            On Local Error GoTo ErrLine

            For iCount = 1 To Len(bstrBuffer) 'set up a loop to remove the vbNullChar's from the buffer.
                  bstrChar = Strings.Mid(bstrBuffer, iCount, 1)
                  If bstrChar <> vbNullChar And bstrChar <> vbNullString Then bstrReturn = (bstrReturn + bstrChar)
            Next
            Buffer_ParseEx = bstrReturn
            Exit Function

ErrLine:
            Err.Clear
            Exit Function
            End Function


            ' ******************************************************************************************************************************
            ' * procedure name: GetTempDirectory
            ' * procedure description:  Returns a bstr String representing the fully qualified path to the system's temp directory
            ' *
            ' ******************************************************************************************************************************
            Public Function GetTempDirectory() As String
            Dim bstrBuffer As String * MAX_PATH
            On Local Error GoTo ErrLine

            'call the win32api
            Call GetTempPath(MAX_PATH, bstrBuffer)
            'parse & return the value to the client
            GetTempDirectory = Buffer_ParseEx(bstrBuffer)
            Exit Function

ErrLine:
            Err.Clear
            Exit Function
            End Function



            ' ******************************************************************************************************************************
            ' * procedure name: File_Exists
            ' * procedure description:  Returns true if the specified file does in fact exist.
            ' *
            ' ******************************************************************************************************************************
            Public Function File_Exists(bstrFileName As String) As Boolean
            Dim WFD As WIN32_FIND_DATA, hFile As Long
            On Local Error GoTo ErrLine

            hFile = FindFirstFile(bstrFileName, WFD)
            File_Exists = hFile <> INVALID_HANDLE_VALUE
            Call FindClose(hFile)
            Exit Function

ErrLine:
            Err.Clear
            Exit Function
            End Function


            ' ******************************************************************************************************************************
            ' * procedure name: File_Delete
            ' * procedure description:  This will delete a File. Pass any of the specified optionals to invoke those particular features.
            ' *
            ' ******************************************************************************************************************************
            Public Function File_Delete(bstrFileName As String, Optional SendToRecycleBin As Boolean = True, Optional Confirm As Boolean = True, Optional ShowProgress As Boolean = True) As Long
            Dim fileop As SHFILEOPSTRUCT
            Dim WFD As WIN32_FIND_DATA, hFile As Long
            On Local Error GoTo ErrLine

            'check argument
            If Right(bstrFileName, 1) = "\" Then bstrFileName = Left(bstrFileName, (Len(bstrFileName) - 1))
            'ensure the file exists
            hFile = FindFirstFile(bstrFileName, WFD)
            If hFile = INVALID_HANDLE_VALUE Then
               Call FindClose(hFile)
               Exit Function
            Else: Call FindClose(hFile)
            End If
            'set the error mode
            Call SetErrorMode(SEM_NOOPENFILEERRORBOX + SEM_FAILCRITICALERRORS)
            'set up the file operation by the specified optionals
            With fileop
                .hWnd = 0: .wFunc = FO_DELETE
                .pFrom = UCase(bstrFileName) & vbNullChar & vbNullChar
                If SendToRecycleBin Then   'goes to recycle bin
                   .fFlags = FOF_ALLOWUNDO
                   If Confirm = False Then .fFlags = .fFlags + FOF_NOCONFIRMATION  'do not confirm
                   If ShowProgress = False Then .fFlags = .fFlags + FOF_SILENT  'do not show progress
                Else 'just delete the file
                   If Confirm = False Then .fFlags = .fFlags + FOF_NOCONFIRMATION  'do not confirm
                   If ShowProgress = False Then .fFlags = .fFlags + FOF_SILENT  'do not show progress
                End If
            End With
            'execute the file operation, return any errors..
            File_Delete = SHFileOperation(fileop)
            Exit Function

ErrLine:
            File_Delete = Err.Number  'if there was a abend in the procedure, return that too..
            Err.Clear
            Exit Function
            End Function


            ' ******************************************************************************************************************************
            ' * procedure name: File_Execute
            ' * procedure description:  Executes a file using it's default shell command and returns a handle to the new process.
            ' *                                       Function returns zero if the operation fails.  Never displays any error dialogs for the user.
            ' *
            ' ******************************************************************************************************************************
            Public Function File_Execute(bstrDirectory As String, bstrFile As String, Optional bstrArguments As String, Optional Show As Long = 1) As Long
            Dim ExecInfo As SHELLEXECUTEINFO
            On Local Error GoTo ErrLine

            'verify argument(s)
            If Len(bstrDirectory) > 0 Then
               If Right(bstrDirectory, 1) = "\" Then
                  bstrDirectory = Trim(LCase(Mid(bstrDirectory, 1, Len(bstrDirectory) - 1)))
               End If
            ElseIf Len(bstrFile) > 0 Then
               If Right(bstrFile, 1) = "\" Then
                  bstrFile = Trim(LCase(Mid(bstrFile, 1, Len(bstrFile) - 1)))
               End If
            End If

            'fill data struct
            With ExecInfo
            .nShow = 1
            .cbSize = Len(ExecInfo)
            .lpFile = bstrFile
            .lpDirectory = bstrDirectory
            .lpParameters = bstrArguments
            .fMask = SEE_MASK_FLAG_NO_UI + SEE_MASK_DOENVSUBST + SEE_MASK_NOCLOSEPROCESS '+ CREATE_NEW_CONSOLE
            End With

            'execute the application
            Call ShellExecuteEx(ExecInfo)
            'return the process id to the client
            File_Execute = ExecInfo.hProcess
            Exit Function

ErrLine:
            Err.Clear
            Exit Function
            End Function